SuperHack/SuperHack CD.bin/CODING/DEMOS/BURN11.ZIP/BURN.PAS

Pascal/Delphi Source File | 1995-05-19 | 8.8 KB | 394 lines

{$A+,B-,D+,E+,F-,G+,I-,L+,N+,O-,P+,Q-,R-,S-,T-,V-,X+,Y+}
{$M 16384,0,655360}

{

Hi guys, try this, use it in your code, but please credit

Frank Jan Sorensen Alias:Frank Patxi ([e-mail]) for the
fireroutine.

}

{

Hi again, guys!

If you use this code, please also credit me, Joachim Fenkes, 'cause I added
the following speedups:

  -Replaced one tiny loop with a faster Move(...) (not much speedup)
  -Wrote the main display loop in 100% assembler, including a faster random
   number generator (the RNG is only a more or less optimized version of
   Borland's generator (see MEGARAND.ASM), but with the advantage of the
   ultimate crash if you call it normally :-)
  -Changed version number into 1.10 (this isn't a speedup, but necessary :-)

}


Program Burn;
uses
  Dos,Crt;

Const
  RootRand     =  20;   { Max/Min decrease of the root of the flames }
  Decay        =  10;   { How far should the flames go up on the screen? }
                        { This MUST be positive - JF }
  MinY         = 100;   { Startingline of the flame routine.
                          (should be adjusted along with MinY above) }
  Smooth       =   1;   { How descrete can the flames be?}
  MinFire      =  50;   { limit between the "starting to burn" and
                          the "is burning" routines }
  XStart       = 90;   { Startingpos on the screen }
  XEnd         = 210;   { Guess! }
  Width        = XEnd-XStart; {Well- }
  MaxColor     = 110;   { Constant for the MakePal procedure }
  FireIncrease : Byte =   3;  {3 = Wood, 90 = Gazolin}

Var
  Scr : Array[0..199,0..319] Of Byte Absolute $A000:$0000;

Type
  ColorValue     = record
                     R, G, B : byte;
                   end;
  VGAPaletteType = array[0..255] of ColorValue;

procedure FastRand; external; { The famous mega-fast Randommer! }
{$L MEGARAND}

procedure ReadPal(var Pal);
var
  K    : VGAPaletteType Absolute Pal;
  Regs : Registers;
begin
  with Regs do
  begin
    AX := $1017;
    BX := 0;
    CX := 256;
    ES := Seg(K);
    DX := Ofs(K);
    Repeat Until Port[$03DA] And $08 = $08; {Wait for rescan}
    Intr($10,Regs);
  end;
end;

procedure WritePal(var Pal);
Var
  K : VGAPaletteType Absolute Pal;
  Regs : Registers;
begin
  with Regs do
  begin
    AX := $1012;
    BX := 0;
    CX := 256;
    ES := Seg(K);
    DX := Ofs(K);
    Repeat Until Port[$03DA] And $08 = $08; {Wait for rescan}
    Intr($10,Regs);
  end;
end;

Procedure Hsi2Rgb(H, S, I : Real; var C : ColorValue);
{Convert (Hue, Saturation, Intensity) -> (RGB)}
var
  T : Real;
  Rv, Gv, Bv : Real;
begin
  T := H;
  Rv := 1 + S * Sin(T - 2 * Pi / 3);
  Gv := 1 + S * Sin(T);
  Bv := 1 + S * Sin(T + 2 * Pi / 3);
  T := 63.999 * I / 2;
  with C do
  begin
    R := trunc(Rv * T);
    G := trunc(Gv * T);
    B := trunc(Bv * T);
  end;
end; { Hsi2Rgb }

{ Faster put'n get pixel routines!  }

procedure put(x,y : integer; c : byte); assembler;
{ Written by Matt Sottile }
 asm
  mov ax,y
  mov di,ax
  shl ax,8
  shl di,6
  add di,ax
  add di,x
  mov ax,0a000h
  mov es,ax
  mov al,c
  mov es:[di],al
 end;

Function get(x,y : integer):byte; assembler;
{ Put Modified by me }
asm
  mov ax,y
  mov bx,ax
  shl ax,8
  shl bx,6
  add bx,ax
  add bx,x
  mov ax,0a000h
  mov es,ax
  mov al,es:[bx]
end;

Procedure MakePal;
Var
  I : Byte;
  Pal   : VGAPaletteType;

begin
  FillChar(Pal,SizeOf(Pal),0);
  For I:=1 To MaxColor Do
    HSI2RGB(4.6-1.5*I/MaxColor,I/MaxColor,I/MaxColor,Pal[I]);
  For I:=MaxColor To 255 Do
  begin
    Pal[I]:=Pal[I-1];
    With Pal[I] Do
    begin
      If R<63 Then Inc(R);
      If R<63 Then Inc(R);
      If (I Mod 2=0) And (G<53)  Then Inc(G);
      If (I Mod 2=0) And (B<63) Then Inc(B);
    end;
  end;

  WritePal(Pal);

end;


Function Rand(R:Integer):Integer;{ Return a random number between -R And R}
begin
  Rand:=Random(R*2+1)-R;
end;

Procedure Help;
Var
  Mode : Byte;
  R    : Registers;
begin
  R.Ax:=$0F00;
  Intr($10,R);
  Mode:=R.Al;
  R.Ax:=$0003;  {TextMode}
  Intr($10,R);

  ClrScr;
  WriteLn('Burn version 1.10');
  WriteLn;
  WriteLn('Light''n''play');
  WriteLn;
  WriteLn('Keys : ');
  WriteLn('<space> : Throw in a match');
  WriteLn('<W>     : Water');
  WriteLn('<+>     : Increase intensity');
  WriteLn('<->     : Decrease intensity');
  WriteLn('<C>     : Initialize fire');
  WriteLn('<1>..<9>: Burnability (1=Wood, 9=Gaz)');
  WriteLn('<?>     : This help');
  WriteLn;
  Write('Hit any key kid >');
  ReadKey;
  R.Ax:=$0000+Mode;
  Intr($10,R);
  If Mode = $13 Then MakePal;
end;

Var
  FlameArray : Array[XStart..XEnd] Of Byte;
  LastMode : Byte;
  I,J : Integer;
  X,P : Integer;
  MoreFire,
  V   : Integer;
  R   : Registers;
  Ch  : Char;
begin

  Help;
  RandomIze;
  R.Ax:=$0F00;
  Intr($10,R);
  LastMode:=R.Al;
  R.Ax:=$0013;
  Intr($10,R);

  MoreFire:=1;
  MakePal;

{
  (* Use this if you want to view the palette *)
  For I:=0 To 255 Do
  For J:=0 To 20 Do
    Put(I,J,I);
  ReadKey;
}

  { Initialize FlameArray }
  For I:=XStart To XEnd Do
    FlameArray[I]:=0;

  FillChar(Scr,SizeOf(Scr),0); { Clear Screen }

  repeat
    If KeyPressed Then Ch:=ReadKey Else Ch:='.'; {'.' = Nothing (Dummy)}

    While KeyPressed Do ReadKey;  { Empty Keyboard buffer }

    { Put the values from FlameArray on the bottom line of the screen }
    Move(FlameArray, Scr[199, XStart], Width+1);

    { This loop makes the actual flames }

    { Here comes my assembler code - JF }

    { There's still a little bug in the code: When you have started the fire,
      some pixels near the upper left corner of the screen dance around. }

    asm
       cld
       push DS
       mov AX, 0A000h
       mov ES, AX
       mov DS, AX
       mov AX, MinY*320+XStart
       mov SI, MinY*320+XStart
       mov DI, MinY*320+XStart-320
       mov CX, 200-MinY
@@1:
         push CX
         mov CX, Width+1
@@2:
           lodsb
           cmp AL, Decay
           jb  @@3
           cmp CX, 2
           jb  @@3
           cmp CX, Width-1
           ja  @@3
           push CX
           push AX
           mov BX, 3
           call FastRand
           dec AX
           push AX
           mov BX, Decay
           call FastRand
           pop DX
           pop CX
           sub CL, AL
           mov AL, CL
           sub DI, DX
           stosb
           add DI, DX
           pop CX
           loop @@2

         add SI, 319-Width
         mov DI, SI
         sub DI, 320
         pop CX
         loop @@1

       jmp @@4

@@3:       xor AL, AL
           stosb
           loop @@2

         add SI, 319-Width
         mov DI, SI
         sub DI, 320
         pop CX
         loop @@1

@@4:   pop DS
    end;

{
  (* This was the original code I translated to assembler - JF *)

    For I:=XStart To XEnd Do
    For J:=MinY To 199 Do
    begin
      V:=VMem[J, I];
      If (V=0) Or
         (V<Decay) Or
         (I<=XStart) Or
         (I>=XEnd) Then
        Put(I, Pred(J), 0);
      else
        Put(I-Pred(Random(3)), Pred(J), V-Random(Decay));
    end;
}

    {Match?}
    If (Random(150)=0) Or (Ch=' ') Then
      FillChar(FlameArray[XStart+Random(XEnd-XStart-5)],5,255);

    {In-/Decrease?}
    If (Ch='-') Then If MoreFire >-2 Then Dec(MoreFire);
    If (Ch='+') Then If MoreFire < 4 Then Inc(MoreFire);

    {!!}
    If UpCase(Ch) = 'C' Then FillChar(FlameArray,SizeOf(FlameArray),0);
    If UpCase(Ch) = 'W' Then
      for I:=1 To 10 Do FlameArray[XStart+Random(Width)]:=0;

    If Ch = '?' Then Help;

    if Ch in ['1'..'9'] Then FireIncrease:=3+Sqr(Ord(Ch)-Ord('1'));

    {This loop controls the "root" of the
     flames ie. the values in FlameArray.}
    For I:=XStart To XEnd Do
    begin
      X:=FlameArray[I];

      If X<MinFire Then { Increase by the "burnability"}
      begin
        {Starting to burn:}
        If X>10 Then Inc(X,Random(FireIncrease));
      end
      else
      { Otherwise randomize and increase by intensity (is burning)}
        Inc(X,Rand(RootRand)+MoreFire);
      If X>255 Then X:=255; { X Too large ?}
      FlameArray[I]:=X;
    end;


    { Pour a little water on both sides of
      the fire to make it look nice on the sides}
    For I:=1 To Width Div 8 Do
    begin
      X:=Trunc(Sqr(Random)*Width/8);
      FlameArray[XStart+X]:=0;
      FlameArray[XEnd-X]:=0;
    end;

    {Smoothen the values of FrameArray to avoid "descrete" flames}
    P:=0;
    For I:=XStart+Smooth To XEnd-Smooth Do
    begin
      X:=0;
      For J:=-Smooth To Smooth Do Inc(X,FlameArray[I+J]);
      FlameArray[I]:=X Div (2*Smooth+1);
    end;
  Until Ch=#27;
  {Restore video mode}
  R.Ax:=$0000+LastMode;
  Intr($10,R);
  {Good bye}
end.